;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;; Copyright (C) 2021 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; Brief: A quaject for keeping configuration together.
;; Author: Maxime Devos
;; This module has quite some differences from the C implementation.

(define-library (gnu gnunet config db)
  (export <configuration>
	  make-configuration
	  configuration?
	  read-value
	  set-value!
	  undefine-key!
	  #; notify-me-on-change!

	  &config-error make-config-error config-error?
	  config-error-section config-error-key
	  &undefined-key-error make-undefined-key-error undefined-key-error?
	  &unwritable-key-error make-unwritable-key-error unwritable-key-error?
	  &unundefinable-key-error make-unundefinable-key-error
	  unundefinable-key-error?

	  hash->configuration
	  hash-key key=?)
  (import (only (rnrs base)
		begin define lambda assert cons string? if
		let values and eq? + car cdr string=?)
	  (only (rnrs exceptions)
		raise)
	  (only (rnrs records syntactic)
		define-record-type)
	  (only (rnrs conditions)
		define-condition-type &error)
	  (only (rnrs hashtables)
		hashtable-ref hashtable-set! hashtable-delete!
		hashtable-contains? hashtable? hashtable-mutable?
		string-hash)
	  (srfi srfi-26)
	  (only (srfi srfi-8)
		receive)
	  (only (ice-9 optargs)
		lambda*))
  (begin
    (define-condition-type &config-error &error
      make-config-error config-error?
      (section config-error-section)
      (key config-error-key))

    (define-condition-type &undefined-key-error &config-error
      make-undefined-key-error undefined-key-error?)
    (define-condition-type &unwritable-key-error &config-error
      make-unwritable-key-error unwritable-key-error?)
    (define-condition-type &unundefinable-key-error &config-error
      make-unundefinable-key-error unundefinable-key-error?)

    
    ;; The configuration quaject.
    ;; The concept quaject is documented in
    ;; <https://valerieaurora.org/synthesis/SynthesisOS/ch4.html>.

    (define (default-read-value/raw section key)
      (raise (make-undefined-key-error section key)))
    (define (default-set-value!/raw section key value)
      (raise (make-unwritable-key-error section key)))
    (define (default-undefine-key! section key)
      (raise (make-unundefinable-key-error section key)))

    (define-record-type (<configuration> make-configuration configuration?)
      (fields (mutable read-value/raw %read-value/raw %set-read-value/raw!)
	      (mutable set-value!/raw %set-value!/raw %set-set-value!/raw!)
	      (mutable undefine-key! %undefine-key! %set-undefine-key!!)
	      #;(immutable notify-me-on-change! ...))
      (sealed #f)
      (opaque #t)
      (protocol (lambda (%make)
		  (lambda* (#:key
			    (read-value/raw default-read-value/raw)
			    (set-value!/raw default-set-value!/raw)
			    (undefine-key! default-undefine-key!))
		    "Make a configuration quaject, that reads configuration
values with the callentry @var{read-value/raw}, writes configuration values
with the callentry @var{set-value!/raw} and undefines values with the
callentry @var{undefine-key!}.  They default to procedures raising
a @code{&undefined-key-error}, @code{&unwritable-key-error} and
@code{&unundefinable-key-error} respectively.

The @var{read-value/raw} callentry accepts a section and key as strings,
and is expected to return a string or raise a @code{&undefined-key-error}.
The @var{undefine-key!} callentry accepts a section and key as strings,
and is expected to raise a @code{&unundefinable-key-error} when appropriate
(e.g. when the key was already undefined).
The @var{set-value!/raw} callentry accepts a section, key and value as string,
and is expected to raise a @code{&unwritable-key-error} when appropriate
(e.g. the configuration is read-only).

Three additional values are returned: a mutator for the @var{read-value/raw},
@var{set-value!/raw} and @var{undefine-key!} callentries.  More values may be
returned in a later version."
		    (let ((c (%make read-value/raw set-value!/raw
				    undefine-key!)))
		      (values c
			      (cut %set-read-value/raw! c <>)
			      (cut %set-set-value!/raw! c <>)
			      (cut %set-undefine-key!! c <>)))))))

    (define (read-value value->object config section key)
      "Return the value of the key @var{key} in the section @var{section}
of the configuration @var{config}.  The raw value string with
@var{value->object} in tail position.  The raw value is retrieved with
the @code{read-value/raw} callentry of @var{config}, which is expected
to raise a @code{&undefined-key-error} exception when appropriate, which will
be propagated."
      (value->object ((%read-value/raw config) section key)))

    (define (set-value! object->value config section key object)
      "Write the object @var{object} to the key @var{key} in the section
@var{section} in the configuration @var{config}.  The conversion to a
raw value string is done with @var{object->value}.  The raw value is
written with the @code{set-value!/raw} callentry of @var{config}, which
is expected to raise a @code{&unwritable-key-error} exception when appropriate,
which will be propagated."
      ((%set-value!/raw config) section key (object->value object)))

    (define (undefine-key! config section key)
      "Undefine the value of the key @var{key} in the section @var{section}
of the configuration @var{config}.  When appropriate (e.g. the configuration
is read-only or the key is already undefined), the @code{undefine-key!}
callentry of @var{config} is expected to raise a
@code{&unundefinable-key-error}, which will be propagated."
      ((%undefine-key! config) section key))

    
    ;; Configuration quaject implementation.
    (define *unequal* (cons #f #f))

    (define (hash-key section+key)
      "Hash a @code{(section . key)} pair, for use in R6RS hash tables."
      ;; Wild guess.
      (+ (string-hash (car section+key))
	 (string-hash (cdr section+key))))
    (define (key=? section+key/1 section+key/2)
      (and (string=? (car section+key/1) (car section+key/2))
	   (string=? (cdr section+key/1) (cdr section+key/2))))

    (define (hash->configuration hash)
      "Make a configuration quaject backed by the hash table @var{table}.
The keys are pairs @code{(section . key)}, where @var{section} and @var{key}
are strings.  The values are the raw string values.  The contents of
@var{hash} is not verified, but presumed to be correctly typed.

Currently, one additional value is returned: a mutator for replacing the
hash table in use.  Replacing the hash table is not an atomic operation;
while the hash table is being replaced, either the new or the old hash
table will be used by the callentries."
      (define (%read-value/raw hash section key)
	(assert (and (string? section) (string? key)))
	;; Grrr SRFI hash-table-ref is nicer
	(let ((value (hashtable-ref hash (cons section key) *unequal*)))
	  (if (eq? *unequal* value)
	      (raise (make-undefined-key-error section key))
	      value)))
      (define (%set-value!/raw-mutable hash section key value)
	(assert (and (string? section) (string? key) (string? value)))
	(hashtable-set! hash (cons section key) value))
      (define (%undefine-key!/mutable hash section key)
	(assert (and (string? section) (string? key)))
	(let ((k (cons section key)))
	  (if (hashtable-contains? hash k)
	      (hashtable-delete! hash (cons section key))
	      (raise (make-unundefinable-key-error section key)))))
      (receive (c set-read-value/raw! set-set-value!/raw!
		  set-undefine-key!!)
	  (make-configuration
	   #:read-value/raw (cut %read-value/raw hash <> <>)
	   #:set-value!/raw (if (hashtable-mutable? hash)
				(cut %set-value!/raw-mutable hash <> <> <>)
				default-set-value!/raw)
	   #:undefine-key!  (if (hashtable-mutable? hash)
				(cut %undefine-key!/mutable hash <> <>)
				default-undefine-key!))
	(values c
		(lambda (hash)
		  (assert (hashtable? hash))
		  (set-read-value/raw! (cut %read-value/raw hash <> <>))
		  (set-set-value!/raw!
		   (if (hashtable-mutable? hash)
		       (cut %set-value!/raw-mutable hash <> <> <>)
		       default-set-value!/raw))
		  (set-undefine-key!!
		   (if (hashtable-mutable? hash)
		       (cut %undefine-key!/mutable hash <> <>)
		       default-undefine-key!))))))))
